(*___________________________________________________________________________*)
(*                                                                           *)
(*                           ARBRE LEXICAL                                   *)
(*___________________________________________________________________________*)

open Str

type noeud_lex = Lettre of char * int * arbre_lex 
	and  arbre_lex = noeud_lex  list


class abrLex =
object(this)

(* Conversion string -> char list *)
method private explode s =
	let rec f acc = function
		| -1 -> acc
		| k -> f (s.[k] :: acc) (k - 1)
in f [] (String.length s - 1)

(* Conversion char -> string pour pouvoir concatener *)
method  private string_of_char n = String.make 1 n

(* Depile '_a list ref -> 'a *)
method private  depiler l = match l with 
	 e::li -> li
	|_ -> failwith "Liste vide"

(* Renvoie le sommet de la pile *)
method private premier l = match l with
	 e::li -> e
	|_ -> failwith "Liste vide"

(* Affiche la liste avec un \n apres chaque element *)
method print_list = function
	[] -> ()
	|e::l -> Printf.printf "%s\n" e	; this#print_list l 

(* Fonctions pour le tri de la liste (string * int) list 
	en fonction de int en decroissant*)

method private max m1 m2 = match m1,m2 with
	 (w1,n1),(_,n2) when n1 >= n2 -> (w1,n1)
	|(_,_),(w2,n2) -> (w2,n2)

method remove x liste = match liste with
	 [] -> failwith "Wtf ?"
	|(w1,n1)::l when (w1,n1) = x -> l
	|e::l -> e::(this#remove x l)

method private get_max = function
	 [] -> ("",0)
	|e::l -> max e (this#get_max l)  

(* Trier non seulement trie la liste en fonction des int
	mais rajoute aussi le debut du mot a chaque element 
	et renvoie la string list finale *)
method trier_liste start l = match l with
	 [] -> []
	|l -> let x = this#get_max l in 
		match x with 
		(a,_) -> (start^a) :: (this#trier_liste start (this#remove x l))

(* Find trouve si dans l'etage du dictionnaire la lettre existem
	Si oui, il nous retourne le dictionnaire d'en-dessous 
	Si non, la liste vide *)
method find x = function
	 [] -> []
	|Lettre(a,_,l)::l2 when a = x -> l
	|Lettre(_,_,_)::l2 -> this#find x l2

(* Recherche renvoie le sous-arbre du dictionnaire 
	correspondant au debut du mot envoye *)
method recherche m d =
	let word = this#explode m in
		let rec doIt d = function
			 [] -> d
	 		|e::l when d <> [] -> doIt (this#find e d) l
			|_ -> []
		in doIt d word 

method exists m d =
	let word = this#explode m in
		let rec doIt d = function
			 [] -> true
			|e::l when d <> [] -> doIt (this#find e d) l 
			|_ -> false
		in doIt d word

method private get_word buf start finish =
	let splitbuf = this#explode buf in
		let rec doIt buf i start finish = match buf with
	 		 [] -> failwith ("Error : FUCK i out of bounds of buf FUCK AGAIN")
			|e::l when i < start -> doIt l (i+1) start finish
			|e::l when i <= finish -> (this#string_of_char e) ^ (doIt l (i+1) start finish)
			|_ -> ""
		in doIt splitbuf 0 start finish

method color_buf d buf =
	let splitbuf = this#explode buf in
		let rec doIt splittedbuf d start i = match splittedbuf with
			 [] -> ()
			|e::l when e = ' ' & this#exists (this#get_word buf start (i-1)) d -> 
					(* colorier buf i j *)
					doIt l d (i+1) (i+1)
			|e::l when e = ' ' -> doIt l d (i+1) (i+1)
			|e::l -> doIt l d start (i+1)
		in doIt splitbuf d 0 0

(* Ajoute un mot m (string) au dictionnaire d *)
method ajoute m d = 
	let aux sm i n = 
		if n = 0 then d 
		else match d with 
			 [] -> [Lettre (sm.[i], (if (n = 1) then 1 else 0), this#ajoute (String.sub sm (i+1) (n-1)) [])]
			| (Lettre(c,b,l))::q when c=sm.[i]-> 
				if n = 1 then (Lettre(c,b+1,l))::q
				else Lettre(c,b,this#ajoute (String.sub sm (i+1) (n-1)) l)::q
			| (Lettre(c,b,l))::q -> (Lettre(c,b,l))::(this#ajoute sm q)
	in aux m 0 (String.length m)

(* Ajoute une liste de mots (string list) au dictionnaire d *)
method ajoute_liste l d = match l with
	 [] -> [""]
	|e::li -> this#ajoute_liste li (this#ajoute e d)

(* Construit un dictionnaire a partir d'un texte s *)
method construit s = 
	let rec aux l d = match l with 
		[] -> d
		| t::q when t <> "" -> aux q (this#ajoute t d) 
		| t::q -> aux q d
    in aux (Str.split (Str.regexp " +\\|\n+\\|(+\\|)+\\|\\[+\\|\\]+\\|{+\\|}+\\|\\.+\\|,+\\|;+\\|:+\\|/+\\|>+\\|<+\\|&") s) []

(* Get pile permet de recuperer la string a partir d'une pile de char *)
method get_pile pile = 
	let piletmp = ref pile and word = ref "" in
		while (!piletmp <> [] & ((this#premier !piletmp) <> '~')) do
			begin
			word := this#string_of_char (this#premier !piletmp) ^ !word;
			piletmp := this#depiler !piletmp
			end		
		done;
		!word

val mutable pile = []
val mutable liste = []
val mutable arbre = (Lettre('~',0,[])::[])

method create_list = function
	 Lettre (x, b, []) when b <> 0 -> pile <- x::pile; 
        liste <- (this#get_pile pile,b)::liste;
        pile <- this#depiler pile; ()
	|Lettre (x, 0, []) -> ()
	|Lettre (x, b, l) when b <> 0 ->  pile <- x::pile; 
        liste <- (this#get_pile pile,b)::liste;
        pile <- this#depiler pile;
        this#create_list (Lettre (x, 0, l)); ()
	|Lettre (x, 0, e::l) ->  pile <- x::pile; 
        this#create_list e; 
        pile <- this#depiler pile; 
        this#create_list (Lettre(x, 0, l)); ()
	|_ -> failwith " Probleme chelou, a voir"

method get_list m d = 
	pile <- [];
	liste <- []; 
	arbre <- this#recherche m d;
	this#create_list (Lettre ('~',0,arbre));
    List.rev (this#trier_liste m liste)

end
